home *** CD-ROM | disk | FTP | other *** search
/ The CICA Windows Explosion! / The CICA Windows Explosion! - Disc 2.iso / programr / wtj008.zip / PORTING.ZIP / ACK.FOR next >
Text File  |  1992-06-08  |  5KB  |  165 lines
  1. c----------------------------------------------------------------------
  2. c  setupDLL initialises the data shared by the DLL and the front-end,
  3. c  and passes addresses over using callbacks.
  4. c----------------------------------------------------------------------
  5.  
  6.       subroutine setupDLL
  7.       
  8. c --- variables that are going to be shared with the front-end need
  9. c --- to be in common blocks.
  10.  
  11.       common /cack/ m,n,iack
  12.       integer *4 m,n,iack
  13.       common /ctrl/ abort
  14.       integer*4 abort
  15.  
  16.       common /cpush/ ipt, mvec, nvec, irtvec
  17.       integer*4 ipt, mvec(10000), nvec(10000), irtvec(10000)
  18.       
  19.       character*10 a_name
  20.       
  21. c --- pass over the addresses of the variables we're going to share
  22. c --- with the front-end
  23.  
  24.       abort = 0
  25.       iack = 0
  26.       ipt = 0
  27.       m = 1
  28.       n = 2
  29.       
  30.       a_name = 'm' C
  31.       call setIntAddr(a_name,m)
  32.       a_name = 'n' C
  33.       call setIntAddr(a_name,n)
  34.       a_name = 'iack' C
  35.       call setIntAddr(a_name,iack)
  36.       a_name = 'ipt' C
  37.       call setIntAddr(a_name,ipt)
  38.       a_name = 'abort' C
  39.       call setIntAddr(a_name,abort)
  40.  
  41.       return
  42.       end
  43.       
  44. c----------------------------------------------------------------------
  45. c  Calculates Ackerman's Function
  46. c
  47. c     if m=0 then n+1
  48. c     else if n=0 then A(m-1,1)
  49. c     else A(m-1, A(m,n-1))
  50. c
  51. c  The recursion depth (and time taken) increases dramatically for
  52. c  quite small changes in m and n..... A(3,6) takes a couple of
  53. c  minutes, while A(4,1) takes a very long time!
  54. c
  55. c  This code was modified from a program given in
  56. c    "Fortran Techniques" by A.Colin Day,
  57. c    Cambridge University Press, 1972
  58. c
  59. c----------------------------------------------------------------------
  60.       subroutine ackerman
  61.  
  62.       common /cack/ m,n,iack
  63.       integer *4 m,n,iack
  64.       common /cpush/ ipt, mvec, nvec, irtvec
  65.       integer*4 ipt, mvec(10000), nvec(10000), irtvec(10000)
  66.       
  67.       integer*4 push,istat
  68.       character*20 txt
  69.       character*80 title,msg
  70.       
  71.       ipt = 0
  72.  
  73.       istat = push(m,n,1)
  74.       if (istat.lt.0) goto 50
  75.       
  76.   200 if (mvec(ipt).gt.0) goto 211
  77.       iack = nvec(ipt) + 1
  78.       goto 277
  79.   211 if (nvec(ipt).gt.0) goto 222
  80.       istat = push(mvec(ipt)-1,1,2)
  81.       if (istat.lt.0) goto 50
  82.       
  83.       goto 200
  84.    20 goto 277
  85.   222 istat = push(mvec(ipt), nvec(ipt)-1, 3)
  86.       if (istat.lt.0) goto 50
  87.       
  88.       goto 200
  89.    30 istat = push(mvec(ipt)-1, iack, 4)
  90.       if (istat.lt.0) goto 50
  91.       
  92.       goto 200
  93.    40 continue
  94.   277 irt = irtvec(ipt)
  95.       ipt = ipt-1
  96.       goto (10,20,30,40), irt
  97.       
  98. c --- If PUSH has signalled an error, the code ends up here. A value
  99. c --- of -1 means the stack has overflowed, and in this case, the DLL 
  100. c --- causes a UAE, and brings the program to a halt. We could just as
  101. c --- easily have passed an error flag back to the calling routine.
  102. c --- A value of -99 means that the user has interrupted the
  103. c --- calculation, so we can just return.
  104.  
  105.    50 continue
  106.       if (istat .eq. -1) then
  107.         txt = 'Stack Overflow!' C
  108.         call bombOut(txt)
  109.       else if (istat .eq. -99) then
  110.         title = 'Ackerman' C
  111.         msg = 'User interrupt' C
  112.         call doMsg(title,msg)
  113.       endif
  114.    
  115. c-----result is in iack      
  116.    10 continue
  117.     
  118.       return
  119.       end
  120.       
  121. c----------------------------------------------------------------------
  122. c  push implements the stack handling for recursive calculation of
  123. c  Ackerman's function.
  124. c----------------------------------------------------------------------
  125.  
  126.       integer*4 function push (m,n,iret)
  127.       common /cpush/ ipt, mvec, nvec, irtvec
  128.       integer*4 ipt, mvec(10000), nvec(10000), irtvec(10000)
  129.  
  130.       common /ctrl/ abort
  131.       integer*4 abort
  132.  
  133.       character*80 buff
  134.       
  135. c --- call WinYield to allow other Windows apps to get a look in...
  136.  
  137.       call WinYield
  138.  
  139. c --- check the abort flag - if it is set, return an error.
  140.       
  141.       if (abort.ne.0) then
  142.         push = -99
  143.         return
  144.       endif
  145.  
  146. c --- else process this call...
  147.       
  148.       ipt = ipt + 1
  149.       if (ipt .le. 10000) then
  150.         if (mod(ipt,10).eq.0) then
  151.           write(buff,'(a13,i5,a1)') 'Stack level: ',ipt,char(0)
  152.           call c_update_window(buff)
  153.         endif
  154.       
  155.         mvec(ipt) = m
  156.         nvec(ipt) = n
  157.         irtvec(ipt) = iret
  158.         push = 0
  159.       else
  160.         push = -1               ! stack overflow
  161.       endif
  162.       return
  163.       end
  164.       
  165.